Mac100% 1998 November

home *** CD-ROM | disk | FTP | other *** search

/ Mac100% 1998 November / MAC100-1998-11.ISO.7z / MAC100-1998-11.ISO / ｵﾝﾗｲﾝｿﾌﾄ定点観測 / ﾕｰﾃｨﾘﾃｨ / Mops 3.2.sea / Mops 3.2 / Mops source / PPC source / pnuc2 < prev next >

Wrap

Text File | 1998-06-13 | 16KB | 845 lines

marker m__pnuc2 ¥ ====================== ¥ I/O ¥ ====================== 0 value BUSY ¥ FCB of file involved in asynchronous I/O, or zero if none. ¥ Set from high level, not from here. Cleared here though, ¥ by the completion routine. 0 value CPADDR ¥ Completion routine address, or zero if none. Also serves ¥ as a flag that the next op is to be asynchronous. ¥ *** Actually, I'm not going to attempt asynch I/O on the PPC yet, since I ¥ don't want to have to worry about UPP callbacks! ¥ =========================== ¥ OTHER SYSTEM CALLS ¥ =========================== ¥ we can omit all the handle and pointer stuff here in the nucleus, and just ¥ use SYSCALLs in pStruct. sysCall FreeMem sysCall MaxMem sysCall EventAvail sysCall WaitNextEvent sysCall FindWindow sysCall BlockMoveData : FREE FreeMem ; variable growBytes : FREEBLK growBytes MaxMem ; : EVENT? ¥ ( mask -- b ) fEvent EventAvail 0<> ; : ?EVENT event? ; ¥ legacy name : NEXTEVENT ¥ ( ^event mask -- b ) swap TEidle_vect sleepTicks MMRgn WaitNextEvent ; variable WPtr : FIND-WINDOW ¥ ( point -- part# ^window ) WPtr FindWindow WPtr @ ; ¥ ========================= ¥ LOW-LEVEL STRING HANDLING ¥ ========================= : FILL { addr len char -- } len 0EXIT len FOR char addr c! 1 ++> addr NEXT ; : ERASE ¥ ( addr len -- ) 0 fill ; : BLANKS ¥ ( addr len -- ) $ 20 fill ; : (S=) { addr1 addr2 len -- b } len FOR addr1 c@ addr2 c@ <> IF UNFOR false EXIT THEN 1 ++> addr1 1 ++> addr2 NEXT true ; : S= { addr1 len1 addr2 len2 -- b } len1 len2 = IF addr1 addr2 len1 (s=) ELSE false THEN ; (* MOVE and ALIGNED_MOVE. There's a small problem with MOVE in that it is required by the standard to move the data exactly even if the areas overlap, without propagation effects. "Undefined on overlap" would have allowed better optimization possiblities, although there are probably some situations where the other behavior is better. Anyway we provide both. We do the "undefined on overlap" with ALIGNED_MOVE, which also requires the beginning addresses to be aligned, which they usually are anyway. For MOVE, we call BlockMoveData, which does the right thing, and does it well, especially for the longer moves. There's about a 28 instruction overhead, but the actual moves are optimum for whatever processor we're running on. So even for ALIGNED_MOVE, we call BlockMoveData if the move is long, since for a long enough move there'll always be an advantage in using a processor-specific optimized sequence. We assume that we're not moving code, only data, so we use BlockMoveData rather than BlockMove which flushes the caches. Note we also made this assumption on the 68k, since although we used BlockMove (BlockMoveData not being available on all systems) if possible we optimized small moves to some inline MOVE instructions without a cache flush. Note also that in a future version the code given here for ALIGNED_MOVE might not always be called if the byte count is a literal. In this case we could sometimes generate a better inline sequence. *) : MOVE ¥ ( src dst len -- ) dup NIF drop 2drop EXIT THEN BlockMoveData ; $ BD36 ' move 2- w! ¥ move_h handler code : ALIGNED_MOVE { src dst len ¥ cnt -- } len 0<= ?EXIT len 32 <= IF len 2 >> -> cnt cnt FOR src @ dst ! 4 ++> src 4 ++> dst NEXT len 3 and -> cnt cnt FOR src c@ dst c! 1 ++> src 1 ++> dst NEXT ELSE src dst len BlockMoveData THEN ; ¥ $ BD37 ' aligned_move 2- w! ¥ alignedMove_h handler code : CMOVE { src dst len -- } len FOR src c@ dst c! 1 ++> src 1 ++> dst NEXT ; : UPPER { addr len -- } len FOR addr c@ & a & z within? IF $ 20 xor addr c! ELSE drop THEN 1 ++> addr NEXT ; (* These words are used by the input parsing section. SCAN ( addr len c -- addr' len' ) searches the string ( addr len ) for the character c. addr' is the address of the matching char, and len' is the remaining length (including the matching char). If no match, len' will be zero. Class String+ provides a more complete implementation in its chsearch: method, which has case handling. In the 68k version, SCAN only handles a 16-bit length - we don't have this restriction in the PPC version, although if you exploit this feature your code won't work on the 68k. *) : SCAN { addr len char -- addr' len' } len FOR addr c@ char = IF UNFOR addr len EXIT THEN 1 ++> addr 1 --> len NEXT addr 0 ; : SKIP { addr len char -- addr' len' } len FOR addr c@ char <> IF UNFOR addr len EXIT THEN 1 ++> addr 1 --> len NEXT addr 0 ; : /STRING { addr len n -- addr' len' } addr n + len n - ; ¥ ========================== ¥ INPUT PARSING etc. ¥ ========================== : SOURCE ¥ ( -- addr len ) src-start src-len ; : REST ¥ ( -- addr len ) src-start >in @ + src-len >in @ - ; : SCAN-SRC { c -- } ¥ Scans the input stream for c. Leaves the source ¥ updated to the next character, (so it could be empty if the found char ¥ was the last in the buffer) or overshot if none found (>IN exceeding ¥ SRC-LEN). The caller will need to check for this. rest c scan src-len swap - 1+ >in ! drop ; : SKIP-SRC { c -- } ¥ Skips consecutive delimiters equal to c in the source. ¥ Leaves source updated to the next character, or empty if none. rest c skip src-len swap - >in ! drop ; : SKIP-SRC+ { c -- } ¥ Skips consecutive delimiters equal to c in the source. ¥ If the source gets exhausted before a non-delimiter is found, ¥ keeps calling REFILL to get more. BEGIN c skip-src >in @ src-len < ?EXIT ¥ out on success refill ¥ get next input line NUNTIL ¥ loop if we got it 154 die ¥ "unexpected end of file" ; : PARSE { c ¥ len -- addr len } ¥ Scans the source for delimiter c. Returns ¥ the addr and len of the parsed string, and updates the source ¥ to the remaining string. >in @ c scan-src >in @ over - 1- -> len src-start + len ; : PARSE-WORD ( c -- addr len ) ¥ As for PARSE, but any consecutive initial delimiters are ¥ skipped. If the input is exhausted in the process, ¥ REFILL is called to get more. dup skip-src+ parse ; : PARSE-DLM-STR { c -- addr len } ¥ Scans the source for a string delimited at the ¥ start and end by c. Everything is skipped before the first delimiter. ¥ If the source gets exhausted in the process, REFILL is called to get ¥ more. BEGIN c scan-src >in @ src-len < IF c parse EXIT THEN ¥ found refill NUNTIL 154 die ¥ "unexpecte end of file" ; : "STR" ( -- addr len ) ¥ Scans for a string delimited by "..." & " parse-dlm-str ; : PLACE { addr1 len addr2 -- } ¥ Converts string ( addr1 len ) to a counted string at addr2. ¥ Appends 3 zero bytes, which may be needed for padding, as ¥ well as making it a valid C string. addr2 len + 1+ 3 erase ¥ append zero bytes len addr2 c! ¥ store count byte addr1 addr2 1+ len cmove ¥ move string bytes over ; : WORD { c ¥ addr -- addr } ¥ Parses the source using c as the delimiter (using PARSE-WORD). ¥ Moves the resulting string as a counted string to HERE, and returns ¥ this address. c parse-word CDP #align4 -> addr addr place addr ; : WORD" ( -- addr ) & " word ; : MWORD ( -- addr ) ¥ "Mops word". Called by DEFINED? which is called ¥ by INTERPRET. ¥ Calls WORD with a blank as delimiter, and converts the string ¥ to upper case. Leaves counted string at addr (will be HERE). bl word case_in_names? ?EXIT dup count upper ; : (,STR) ( addr len --) tuck here place 1+ #align4 allot ; : ,STR ( c -- ) ¥ c is delimiter. Adds the following text until delimiter ¥ to the DATA AREA as a counted string. parse (,str) ; : ,DLM-STR ( c -- ) ¥ Scans the source for a string delimited at the ¥ start and end by c, then adds it to the dictionary. parse-dlm-str (,str) ; : ," ( -- ) ¥ Adds text till " to the dictionary. & " ,str ; : ,"STR" ( -- ) ¥ Adds text delimited by " at the start and end. & " ,dlm-str ; ¥ .( - see below, after TYPE : ( & ) parse 2drop ; ppc_immediate : ¥ 0 -> src-len ; ppc_immediate ¥ ====================== ¥ SCREEN OUTPUT ¥ ====================== ¥ First, the sysCalls and low-level stuff: sysCall MoveTo sysCall EraseRect sysCall SetOrigin sysCall Line sysCall ScrollRect sysCall GetPen sysCall GetPenState sysCall SetPenState sysCall PenMode sysCall DrawChar sysCall DrawText : HOME 8 15 MoveTo ; : CLS fpRect EraseRect ; : SCROLL { x y -- } emit? 0EXIT fpRect x y theRgn ScrollRect ; : >ORIGIN ¥ ( x y --) SetOrigin ; : GOTOXY ¥ ( x y -- ) MoveTo ; : @XY ¥ ( -- x y ) tempVbl GetPen tempVbl 2+ w@ tempVbl w@ ; : .CURS ( -- ) emit? 0EXIT curs? 0EXIT tempVbl GetPenState 10 PenMode 7 0 Line tempVbl SetPenState ; : CONTBOT ( -- n ) thePort $ A0 + w@ ; : CONTTOP ( -- n ) thePort $ 9C + w@ ; : #LEAD { ¥ addr -- n } thePort -> addr thePort $ 4A + w@ dup NIF ¥ zero point size, i.e. no font set. We just return 4 so Scroll ¥ doesn't crash. drop 4 EXIT THEN 120 * 50 + 100 / ; : #LINES ( -- n ) contBot contTop - #lead / 1- ; : BOTTOM ( -- n ) #lead #lines 1- * 15 + contTop + ; ¥ ---------------- CR ----------------- : (CR) ( -- ) .curs @xy nip 8 swap dup bottom >= IF 0 #lead negate scroll gotoXY ELSE #lead + gotoXY THEN .curs ; ' (cr) sVect CRVEC : CR crVec ; ¥ ---------------- EMIT ----------------- : (EMIT) { c -- } emit? 0EXIT c $ D = IF crVec ELSE .curs c DrawChar .curs THEN ; ' (emit) sVect EMITVEC ' (emit) sVect ECHOVEC : EMIT ¥ ( c -- ) 1 ++> out emitVec ; ¥ ---------------- TYPE ----------------- : (TYPE) { addr len -- } emit? 0EXIT .curs addr 0 len DrawText .curs ; ' (type) sVect TYPEVEC : TYPE ( addr len -- ) dup ++> out typeVec ; : .( & ) parse type ; ppc_immediate ¥ -------------- SPACE & SPACES --------------- : SPACE bl emit ; : (SPACES) { n -- } emit? 0EXIT n 0<= ?EXIT n padLen min -> n pad n bl fill pad n (type) ; ' (spaces) sVect SPVEC : SPACES ¥ ( n -- ) dup ++> out spVec ; ¥ We only use (BS) internally, so we don't define a BS. : (BS) .curs ¥ erases any cursor on screen curs? false -> curs? @xy swap 6 - 8 max swap 2dup gotoXY space gotoXY -> curs? .curs ¥ draw cursor at new position ; : +ECHO true -> echo? ; : -ECHO false -> echo? ; : +CURS true -> curs? ; : -CURS false -> curs? ; : CURS curs? ; ¥ for backward compatibility ¥ =============================== ¥ KEYBOARD INPUT ¥ =============================== : KEY? ( -- b ) $ 28 event? ; : ?TERMINAL ( -- b ) ¥ the old name key? ; : (KEY) { ¥ what -- c } BEGIN fEvent ¥ addr of our event record $ 843A ¥ Mask - we'll accept key down, auto-key, ¥ mouse-down, high-level and OS events. nextEvent IF ¥ we've got something fEvent w@ -> what ¥ get What field of fEvent what 3 = what 5 = or IF ¥ we've got a key fEvent 5 + c@ ¥ low byte of message field is ASCII key value EXIT ELSE what 23 = IF ¥ High-level event - presumably oapp. ¥ We'll just ignore it. THEN THEN THEN AGAIN ; ' (key) sVect KEY forward get_$input :f get_$input pad 0 ;f : bs_acc #tib @ ¥ at start of TIB? IF (bs) ¥ no - fix screen -1 #tib +! ¥ and back up ELSE 4 beep ¥ yes - beep THEN ; : key_acc { ¥ c loop? -- c } ¥ Reads one key for ACCEPT. Handles backspaces and tabs. BEGIN false -> loop? key -> c ¥ first we check for the chars which we don't echo c 8 = IF bs_acc ¥ handle backspace ELSE c $ FF = IF ¥ ignore FF ELSE ¥ we echo everything else and don't loop c 3 = IF $ D -> c ¥ <enter> replaced with <return> ELSE c 9 = IF bl -> c ¥ tab replaced with blank THEN THEN c echoVec ¥ echo char however we're set up to do it c EXIT THEN THEN AGAIN ; : ACCEPT { addr max_len ¥ c -- #chars } 0 #tib ! ¥ Is there pending input from the Mops window? get_$input ?dup IF ¥ yes - move it to the destination. We can ¥ assume special chars have been filtered. max_len min dup #tib ! addr swap cmove EXIT THEN drop BEGIN key_acc -> c c $ D = IF #tib @ EXIT THEN #tib @ max_len < IF c addr #tib @ + c! ¥ still room in buff - store char 1 #tib +! THEN AGAIN ; : SET_SOURCE TIB -> src-start #tib @ -> src-len 0 >in ! ; : QUERY TIB TIBlen accept drop set_source 0 -> source-ID ; :f REFILL ( -- b ) ¥ attempts to (re)fill the input stream with another line. source-ID dup NIF ¥ it's from the keyboard drop query true ELSE -1 = IF ¥ it's from an EVALUATEd string - none left false ELSE ¥ it's from a file fRefill ¥ - fRefill does the job, and returns the flag. THEN THEN 1 ++> #lines_read ;f ¥ ===================== ¥ NUMBER INPUT ¥ ===================== : >NUMBER ( ud-lo ud-hi ) { addr len -- ud-lo' ud-hi' addr' len' } len 0> IF BEGIN addr c@ 1 ++> addr base digit NIF 1 --> addr false ELSE ( ud-lo ud-hi digit ) swap base * rot base um* d+ dpl 0>= IF 1 ++> dpl THEN 1 --> len len 0> THEN NUNTIL THEN ( ud-lo' ud-hi' ) addr len ; : ?NOTFOUND ( flag -- ) NIF -13 die THEN ¥ "undefined word" ; : NUM? { addr len ¥ start neg? done? -- n true | -- n-lo n-hi true | -- false } false -> neg? false -> done? len NIF false EXIT THEN addr c@ & - = IF ¥ 1st char was minus true -> neg? 1 ++> addr 1 --> len THEN addr -> start ¥ remember initial addr -1 -> dpl ¥ no decimal point seen yet 0 0 ¥ initial number is a double zero BEGIN addr len >number ¥ accumulate digits into number -> len -> addr ¥ update string addr & len len IF addr c@ & . = IF addr -> dpl 1 ++> addr 1 --> len ELSE true -> done? THEN ELSE true -> done? THEN done? UNTIL ¥ we've hit a non-digit or the string is exhausted. len IF 2drop false EXIT THEN ¥ 'number' not completed - probably ¥ bad char in number addr start = IF 2drop false EXIT THEN ¥ no chars processed - not a number dpl 0>= IF ¥ decimal point seen - it's a double number neg? IF dnegate THEN ELSE drop ¥ want a single number - drop hi cell neg? IF negate THEN THEN true ; : NUMBER ( addr -- n ) ¥ returns the number at addr, or if none, ¥ gives "undefined word" error. count num? ?notFound ; ¥ LITERAL is immediate so we'll leave it till the end. ¥ head $47,LITERAL,literal ; LITERAL ¥ callh hLiteral ¥ RTS ¥ ============================= ¥ NUMBER OUTPUT ¥ ============================= : HOLD ( c -- ) 1 --> hld hld c! ; : <# ( d -- d ) pad -> hld ; : #> ( d -- ) 2drop hld pad over - ; : SIGN ( n -- ) 0< IF & - hold THEN ; (* : # drop ¥ get rid of hi-order cell (assumed to be zero) base u/mod swap dup 9 > IF 7 + THEN & 0 + hold 0 ; *) : # base 0 ud/mod 2swap drop dup 9 > IF 7 + THEN & 0 + hold ; : #S ( d -- d' ) BEGIN # 2dup or NUNTIL ; ¥ : HEX 16 -> base ; ¥ : DECIMAL 10 -> base ; : .R { n #to-right -- } n abs 0 <# #s n sign #> #to-right over - spaces type ; : . ¥ ( n -- ) 0 .r space ; : .H base 16 -> base swap . -> base ; : U. 0 <# #s #> type space ; : N>COUNT count $ 1F and ;